home *** CD-ROM | disk | FTP | other *** search
/ Enter 2004 January / enter-2004-01.iso / files / maxima-5.9.0.exe / {app} / share / maxima / 5.9.0 / src / suprv1.lisp < prev    next >
Encoding:
Text File  |  2003-02-09  |  44.2 KB  |  1,293 lines

  1. ;;; -*-  Mode: Lisp; Package: Maxima; Syntax: Common-Lisp; Base: 10 -*- ;;;;
  2. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  3. ;;;     The data in this file contains enhancments.                    ;;;;;
  4. ;;;                                                                    ;;;;;
  5. ;;;  Copyright (c) 1984,1987 by William Schelter,University of Texas   ;;;;;
  6. ;;;     All rights reserved                                            ;;;;;
  7. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  8.  
  9. (in-package "MAXIMA")
  10. ;    ** (c) Copyright 1982 Massachusetts Institute of Technology **
  11.  
  12. ;(macsyma-module suprv)
  13.  
  14. ;;note in converting this file (originally suprv.lisp) to common lisp
  15. ;;for the lisp machine, I removed a lot of the old stuff which did not
  16. ;;apply, and tried to eliminate any / quoting.  Most of the relevant
  17. ;;stuff is in system.lisp for the lispm and nil friends.--wfs
  18.  
  19. ;; #+MACLISP is ITS, Twenex, or Multics MacLisp.
  20. ;; #+PDP10 is ITS or Twenex MacLisp.
  21. ;; #+LISPM is the Lisp Machine or the Lisp Machine compiler running on ITS.
  22. ;; #+MACLISP and #+LISPM indicate which system a piece of code is intended
  23. ;; "for", not which system the code is being compiled "in".
  24. ;; #+GC means include gctime messages, and ok to call GCTWA here and there.
  25. ;; #-MAXII means not needed in new macsyma I/O and system organization.
  26.  
  27. ;; Setting BASE to 10 at compile time needed for LAP to work.
  28.  
  29.  
  30. #-(or cl NIL)
  31. (EVAL-WHEN (EVAL COMPILE)
  32.          (SETQ OLD-IBASE *read-base* OLD-BASE *print-base*) 
  33.        (SETQ *read-base* 10. *print-base* 10.))
  34. #+cl
  35. (EVAL-WHEN (EVAL COMPILE)
  36.          (SETQ OLD-IBASE *READ-BASE* OLD-BASE *PRINT-BASE*) 
  37.        (SETQ *READ-BASE* 10. *PRINT-BASE* 10.))
  38.  
  39. (defmvar mopl nil)
  40.  
  41. (declare-top 
  42.      (SPECIAL M$+ GCFLAG GCT $LASTTIME $PARSETIME $DISPTIME
  43.           BINDLIST LOCLIST ERRSET $LABELS LINELABLE $BATCOUNT $FILESIZE
  44.           ST REPHRASE $DISPFLAG REFCHKL BAKTRCL RUBOUT TTYHEIGHT
  45.           CNTLY NEWLINE DSKFNP DSKSAVEP *RSET CNTL@
  46.           ^W ^R ^Q ^D LF TAB FF CNTLC ALT BATCONL CR VT ^H ^S BSP
  47.           $VALUES $FUNCTIONS $ARRAYS $ALIASES $GRADEFS $DEPENDENCIES
  48.           $RULES $PROPS $RATVARS $RATVARSWITCH DEBUG ERRBRKSW ERRCATCH
  49.           VARLIST GENVAR $DEVICE $FILENAME $FILENUM LBP RBP
  50.           $GENSUMNUM CHECKFACTORS $FEATURES FEATUREL $BACKTRACE
  51.           $WEIGHTLEVELS TELLRATLIST $DONTFACTOR $INFOLISTS LOADFILES
  52.           $DSKALL ERRLIST ALLBUTL LISPERRPRINT BACKRUB
  53.           GC-DAEMON GC-OVERFLOW DEMONL $DYNAMALLOC ALLOCLEVEL INFILE
  54.           ALARMCLOCK $C18MAXTIME $FILEID DCOUNT GCLINENUM THISTIME
  55.           $NOLABELS $BATCHKILL DISPFLAG SAVENO MCATCH BRKLVL SAVEFILE
  56.           STRING ST1 STIME0 $%% $ERROR
  57.           *IN-$BATCHLOAD* *IN-TRANSLATE-FILE*
  58.           LESSORDER GREATORDER $ERRORFUN MBREAK REPRINT POS $STRDISP
  59.           $DSKUSE SMART-TTY RUBOUT-TTY MORE-^W OLDST ALPHABET
  60.           $LOADPRINT TTYINTS OPERS
  61.           *RATWEIGHTS $RATWEIGHTS QUITMSG MQUITMSG CONTMSG
  62.           LOADF DISPLAY-FILE $GRIND SCROLLP $CURSORDISP
  63.           STRINGDISP $LISPDISP MEXPRP DEFAULTF READING
  64.           BPORG GCSYML ^AMSG ^BMSG ^HMSG
  65.           STATE-PDL PROMPTMSG GCPROMPT COMMAND PRINTMSG MRG-PUNT
  66.           NEW-C-LINE-HOOK TRANSP $CONTEXTS $SETCHECK $MACROS
  67.           UNDF-FNCTN AUTOLOAD)
  68. #+CL  (SPECIAL ERROR-CALL)
  69. #+Franz  (special ptport display-to-disk)
  70.      (*EXPR REPRINT)
  71.      (*LEXPR CONCAT $FILEDEFAULTS $PRINT)
  72.      (FIXNUM $FILESIZE DCOUNT $BATCOUNT I N N1 N2 TTYHEIGHT
  73.          $FILENUM THISTIME GCT TIM GCLINENUM ALLOCLEVEL
  74.          BRKLVL CMTCNT BPORG BPORG0 #-cl (COMPUTIME FIXNUM FIXNUM)
  75.          #-cl (CASIFY FIXNUM) #-cl (GETLABCHARN))
  76.      (FLONUM U1 STIME0)
  77.      (NOTYPE (ASCII-NUMBERP FIXNUM))
  78.      (ARRAY* (FIXNUM DISPLAY-FILE 1)))
  79.  
  80.  
  81. ;; This affects the runtime environment.  ALJABR;LOADER also does this, but
  82. ;; leave it here for other systems.  On the Lisp Machine, this is bound
  83. ;; per stack group.
  84.  
  85. (defmvar $prompt
  86.   '_
  87.   nil
  88.   no-reset)
  89.  
  90. (eval-when (compile eval load)
  91.  
  92. (defun control-char (ch)
  93.   (code-char (+ (char-code #\) (- (char-code ch) (char-code #\A)))))
  94. )
  95.  
  96. (PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'OPALIAS))
  97.          '((+ $+) (- $-) (* $*) (// $//) (^ $^) (|.| |$.|) (< $<) (= $=)
  98.            (> $>) (|(| |$(|) (|)| |$)|) (|[| |$[|) (|]| |$]|) (|,| |$,|) (|:| |$:|)
  99.            (|!| |$!|) (|#| |$#|) (|'| |$'|) (|;| |$;|)))
  100.        #+cl
  101.        (MAPC #'(LAMBDA (X) (SET (CAR X)
  102.                 (cond (#-cl (< (cadr x)
  103.                           160)
  104.                         #+cl (char< (cadr x)
  105.                             #. (code-char 160.))
  106.                            (ASCII (CADR X)))
  107.                           (t (cadr x)))))
  108.          '( ;#-cl (CNTL@ #\)
  109.            (CNTLC #. (control-char #\C))
  110.            (BSP #\Backspace) (TAB #\TAB) (LF #\Linefeed)
  111. ;          #-lispm (VT #\VT) ;;would not compile in lispmachine
  112.            (FF #\Page) (CR #\return)
  113.            (CNTLY #.(control-char #\Y))
  114.            (SP #\Space)
  115.            (NEWLINE #\NEWLINE) (RUBOUT #\RUBOUT)))
  116.        (SETQ GCSYML NIL)
  117.        (DOTIMES (I 14.) (PUSH (GENSYM) GCSYML))
  118.    #-cl  (SETQ ALT #-MULTICS (intern (string #\Escape)) #+MULTICS '&)
  119. #-CL (SETQ $PLOTUNDEFINED (*$ 2.0 -8.5070591E+37))
  120.        (SETQ $LASTTIME '((MLIST) 0 0) THISTIME 0 GCT 0 GCFLAG NIL
  121.          $PARSETIME NIL $DISPTIME NIL MEXPRP NIL)
  122.        (SETQ BATCONL NIL $BATCOUNT 0 $BATCHKILL NIL $STRDISP T $GRIND NIL)
  123.        (SETQ REFCHKL NIL DEBUG NIL BAKTRCL NIL ERRBRKSW NIL MBREAK NIL $ERRORFUN NIL
  124.          ERRCATCH NIL DEMONL (LIST NIL) MCATCH NIL BRKLVL -1
  125.          ALLBUTL NIL LOADF NIL $BACKTRACE '$BACKTRACE)
  126.        (SETQ *IN-$BATCHLOAD* NIL *IN-TRANSLATE-FILE* NIL)
  127.        (SETQ BACKRUB #-Franz nil #+Franz t)
  128.        (SETQ $DEBUGMODE NIL $BOTHCASES T
  129.          $PAGEPAUSE NIL $DSKGC NIL $POISLIM 5)
  130.        (SETQ $LOADPRINT NIL ^S NIL LOADFILES NIL)
  131. ;      (SETQ $FILEID NIL $C18MAXTIME 150.0E6)
  132.        (SETQ $NOLABELS NIL $ALIASES '((MLIST SIMP)) LESSORDER NIL GREATORDER NIL)
  133.        (SETQ $INFOLISTS
  134.          (PURCOPY '((MLIST SIMP) $LABELS $VALUES $FUNCTIONS $MACROS $ARRAYS
  135.                      $MYOPTIONS $PROPS $ALIASES $RULES $GRADEFS
  136.                      $DEPENDENCIES $LET_RULE_PACKAGES)))
  137.        (SETQ $LABELS (list '(MLIST SIMP)))
  138.        (setq $DSKUSE NIL $DEVICE '$DSK $DISPFLAG T LINELABLE NIL)
  139.        (SETQ REPHRASE NIL ST NIL OLDST NIL REPRINT NIL POS NIL)
  140.        (SETQ DCOUNT 0 $FILENUM 0 $STORENUM 1000. $FILESIZE 16. $DSKALL T
  141.          NEW-C-LINE-HOOK NIL DSKFNP NIL TTYINTS T
  142.          GCLINENUM 0 DSKSAVEP NIL SAVENO 0 $DYNAMALLOC NIL ALLOCLEVEL 0)
  143.        (SETQ QUITMSG  " "
  144.          MQUITMSG " (Into LISP.  Type control-G to get to MACSYMA.)" 
  145.          CONTMSG  "(Type <space> to continue, <return> to terminate.)"
  146.          ^AMSG    "  (Type EXIT; to exit.)"
  147.          ^BMSG   #-Multics "LISP  (Type <Alt>P<Space> to continue.)" 
  148.              #+Multics "LISP  (Type <Dollarsign>P<Carriage Return> to continue)"
  149.          ^HMSG "
  150.  (Use the RUBOUT or DEL(ETE) key to erase a character.)" ^DMSG-ON "
  151.  (Printout of GC statistics turned on.  Type control-D again to turn them off.)
  152. "         ^DMSG-OFF "
  153.  (Printout of GC statistics turned off.)
  154. "         GCPROMPT "Type ALL; NONE; a level-no. or the name of the space.
  155. "         MORE-^W NIL 
  156.          LISPERRPRINT T PRINTMSG NIL PROMPTMSG NIL MRG-PUNT NIL READING NIL)
  157. ;      (SETQ $CALCOMPNUM 100.)
  158.        (SETQ STATE-PDL (PURCOPY (NCONS 'LISP-TOPLEVEL)))
  159.        #+MULTICS (SETQ $PLOT3DSIZE 20 $MULTGRAPH T)
  160.    ; Slashify ':' on printout on other systems for the benefit of Lispm.
  161. ;;; Figure out how to do the above for Franz.
  162.        '(Random properties))
  163.  
  164. (DEFMVAR $% '$% "The last D-line computed, corresponds to lisp *" NO-RESET)
  165. (DEFMVAR $INCHAR '$C
  166.   "The alphabetic prefix of the names of expressions typed by the user.")
  167. (DEFMVAR $OUTCHAR '$D
  168.   "The alphabetic prefix of the names of expressions returned by the system.")
  169. (DEFMVAR $LINECHAR '$E
  170.   "The alphabetic prefix of the names of intermediate displayed expressions.")
  171. (DEFMVAR $LINENUM 1 "the line number of the last expression." FIXNUM NO-RESET)
  172. (DEFMVAR $DIREC 'JRMU
  173.   "The default file directory for SAVE, STORE, FASSAVE, and STRINGOUT."
  174.   NO-RESET)
  175. (DEFMVAR CASEP T
  176.   "Causes translation of characters from lower to upper case on ITS, 
  177.    and from upper to lower case on Multics and Franz.")
  178. ;(DEFMVAR $ERREXP '$ERREXP)
  179. (DEFMVAR USER-TIMESOFAR NIL)
  180.  
  181.  
  182.  
  183. (DEFVAR MOREMSG "--Pause--")
  184. (DEFVAR MORECONTINUE "--Continued--")
  185. (DEFVAR MOREFLUSH NIL)
  186. (DEFMVAR $MOREWAIT NIL "needs to be documented" NO-RESET)
  187.  
  188. (DEFMVAR $SHOWTIME NIL)
  189.  
  190. (DEFMVAR ALIASLIST NIL
  191.  "is used by the MAKEATOMIC scheme which has never been completed"
  192.  NO-RESET)
  193.  
  194. ;(declare-top (SETQ *print-base* 8))
  195.  
  196.  
  197. (DEFUN SYS-GCTIME ()
  198.   #-Franz (STATUS GCTIME)
  199.   #+Franz (cadr (ptime)))
  200.  
  201.  
  202. ;#.(SETQ NALT #-MULTICS #\ALT #+MULTICS #\&)
  203.  
  204. #-cl
  205. (DEFMVAR $CHANGE_FILEDEFAULTS #+PDP10 T #-PDP10 NIL
  206.      "Does DDT-style file defaulting iff T")
  207.  
  208. (DEFMVAR $FILE_STRING_PRINT #+PDP10 NIL #-PDP10 T
  209.      "If TRUE, filenames are output as strings; if FALSE, as lists.")
  210.  
  211. (DEFMVAR $SHOWTIME #-MULTICS NIL #+MULTICS T)
  212.  
  213.  
  214. (DEFMFUN MEVAL* (TEST)
  215.  (LET (REFCHKL BAKTRCL CHECKFACTORS)
  216.       (PROG2 (IF $RATVARSWITCH (SETQ VARLIST (CDR $RATVARS)))
  217.          (MEVAL TEST)
  218.          (CLEARSIGN))))
  219.  
  220. (DEFMFUN MAKELABEL (X)
  221.  (WHEN (AND $DSKUSE (NOT $NOLABELS) (> (SETQ DCOUNT (f1+ DCOUNT)) $FILESIZE))
  222.        (SETQ DCOUNT 0) (DSKSAVE))
  223.  (SETQ LINELABLE (CONCAT X $LINENUM))
  224.  (IF (NOT $NOLABELS)
  225.      (IF (OR (NULL (CDR $LABELS))
  226.          (WHEN (MEMQ LINELABLE (CDDR $LABELS))
  227.            (DELQ LINELABLE $LABELS 1) T)
  228.          (NOT (EQ LINELABLE (CADR $LABELS))))
  229.      (SETQ $LABELS (CONS (CAR $LABELS) (CONS LINELABLE (CDR $LABELS))))))
  230.  LINELABLE)
  231.  
  232. (DEFMFUN PRINTLABEL NIL
  233.   (MTELL-OPEN "(~A) " (MAKNAM (CDR (EXPLODEN LINELABLE)))))
  234.  
  235. (DEFMFUN MEXPLODEN (X)
  236.   (let ( #-cl(*nopoint t) #+cl *print-radix*
  237.     #+cl (*print-base* 10)
  238.     #+NIL (si:standard-output-radix 10) #-(or cl NIL) (*print-base* 10))
  239.     (EXPLODEN X)))
  240.  
  241. (DEFMFUN ADDLABEL (LABEL)
  242.  (SETQ $LABELS (CONS (CAR $LABELS) (CONS LABEL (DELQ LABEL (CDR $LABELS) 1)))))
  243.  
  244. (DEFMFUN TYI* NIL
  245.  #+Multics (CLEAR-INPUT NIL)
  246.  (DO ((N (TYI) (TYI))) (NIL)
  247.      (COND ((OR (char= N #\NewLine) (AND (> N 31) (NOT (char= N #\RUBOUT))))
  248.         (RETURN N))
  249.        ((char= N #\Page) (FORMFEED) (PRINC (STRIPDOLLAR $PROMPT))))))
  250.  
  251. (DEFUN CONTINUEP NIL
  252.  (PRINC (STRIPDOLLAR $PROMPT))
  253.  (char= (TYI*) #-Multics #\Space #+Multics #\NewLine))
  254.  
  255. (DEFUN CHECKLABEL (X)  ; CHECKLABEL returns T iff label is not in use
  256.  (NOT (OR $NOLABELS (= $LINENUM 0) (BOUNDP (CONCAT X $LINENUM)))))
  257.  
  258. (DEFUN GCTIMEP (TIMEP TIM)
  259.  (COND ((AND (EQ TIMEP '$ALL) (NOT (ZEROP TIM))) (PRINC "Totaltime= ") T)
  260.        (T (PRINC "Time= ") NIL)))
  261.  
  262. ;; If $BOTHCASES is T, lower case letters will not be converted to upper case.
  263.  
  264. (DEFMFUN $BOTHCASES (X) (BOTHCASES1 NIL X))
  265.  
  266. (DEFUN BOTHCASES1 (SYMBOL VALUE)
  267.  SYMBOL ;Always bound to $BOTHCASES.  Ignored.
  268.  ;; This won't work with the Lisp Machine reader.
  269.  #+MacLisp (DO ((I 97. (f1+ I))) ((> I 122.))
  270.            (SETSYNTAX I (IF VALUE 1 321.) (IF VALUE I (f- I 32.))))
  271.  (SETQ CASEP (NOT VALUE)) VALUE)
  272.  
  273. ;(DEFUN BACKSPACE1 (NIL X)
  274. ; (COND (X (ADD2LNC 8 ALPHABET)
  275. ;      (SETSYNTAX 8 322. NIL))
  276. ;       (T (DELETE 8 ALPHABET 1)
  277. ;      (SETSYNTAX 8 131392. NIL)))
  278. ; (SETQ BSPP X))
  279.  
  280. #+CL
  281. (DEFUN LISTEN () 0)  ; Doesn't exist yet.
  282.  
  283. (DEFUN DISPLAY* (&AUX (RET NIL) (TIM 0))
  284.  #+GC (IF (EQ GCFLAG '$ALL) (LET (^D) (GC)))
  285.  (SETQ TIM (RUNTIME)
  286.        RET (LET ((ERRSET 'ERRBREAK2) (THISTIME -1))
  287.         (ERRSET (DISPLA (LIST '(MLABLE) LINELABLE $%)))))
  288.  (IF (NULL RET) (MTELL "~%Error during display~%"))
  289.  (IF $DISPTIME (MTELL-OPEN "Displaytime= ~A msec.~%" (COMPUTIME (RUNTIME) TIM)))
  290.  RET)
  291.  
  292.  
  293. (DEFMFUN RUBOUT* (STG)
  294.  (LET (#.TTYOFF #.WRITEFILEP)
  295.       (COND (RUBOUT-TTY
  296.          (COND ((OR REPRINT (NULL STG)
  297.             (char= (CAR STG) #\return) (char= (CAR STG) #\tAB))
  298.             (COND (SMART-TTY
  299.                (CURSORPOS (CAR POS) (CDR POS)) (CURSORPOS 'L)
  300.                (IF (CDR STG) (PRINC (MAKNAM (REVERSE (CDR STG)))))
  301.                (SETQ REPRINT NIL))
  302.               ((OR REPRINT STG) (REPRINT (CDR STG) NIL))))
  303.            (T (CURSORPOS 'X))))
  304.         (STG (TYO (CAR STG))))))
  305.  
  306.  
  307. (DEFMFUN REPRINT (STG FFP)
  308.  (LET (#.TTYOFF #.WRITEFILEP)
  309.       (IF (NOT FFP) (MTERPRI))
  310.       (CASE (CAR STATE-PDL)
  311.          (MACSYMA-TOPLEVEL (PRINTLABEL))
  312.          (RETRIEVE (IF (EQ MRG-PUNT 'BREAK) (PRINC (STRIPDOLLAR $PROMPT)))))
  313.       (SETQ POS (CURSORPOS))
  314.       (IF STG (PRINC (MAKNAM (REVERSE STG))))
  315.       (SETQ REPRINT NIL)))
  316.  
  317. ;; The PDP10 is one of the only systems which autoload.
  318. ;; The definition for non-autoloading systems is in MAXMAC. - CWH
  319. ;; For now we'll let a USER put autoload properties on symbols
  320. ;; and at least let them get found on Multics. - Jim 3/24/81
  321. ;; Franz also autoloads -- jkf
  322. ;;
  323.  
  324. #+cl
  325. (defun generic-autoload (file &aux type)
  326.   (setq file (pathname (cdr file)))
  327.   (setq type (pathname-type file))
  328.   (cond ((MEMBER type
  329.        '(nil "BIN" "O" "o" "XFASL" "QFASL" "LISP" "LSP") :test 'equalp)
  330.      (load file))
  331.        (t ($batchload file))))
  332. #+cl
  333. (defvar autoload 'generic-autoload)
  334.  
  335.  
  336. #+(or Franz MACLISP NIL cl)
  337. (DEFMFUN LOAD-FUNCTION (FUNC MEXPRP)  ; The dynamic loader
  338.  (LET ((FILE (GET FUNC 'AUTOLOAD)))
  339.       (IF FILE (FUNCALL AUTOLOAD (CONS FUNC FILE)))))
  340.  
  341. (DEFMFUN LOAD-FILE (FILE) ($LOAD (TO-MACSYMA-NAMESTRING FILE)))
  342.  
  343. (DEFMSPEC $LOADFILE (FORM)
  344.  (LOADFILE (FILESTRIP (CDR FORM)) NIL
  345.        (NOT (MEMQ $LOADPRINT '(NIL $AUTOLOAD)))))
  346.  
  347.  
  348.  
  349. #-(or Franz cl cl)
  350. (DEFMSPEC $SETUP_AUTOLOAD (L)
  351.   (SETQ L (CDR L))
  352.   (show l)
  353.   (IF (NULL (CDR L)) (WNA-ERR '$SETUP_AUTOLOAD))
  354.   (LET ((FILE #-PDP10 ($FILE_SEARCH ($FILENAME_MERGE 
  355.                      (CAR L)
  356.                      (USER-WORKINGDIR-PATHNAME)))
  357.           #+PDP10 (NAMELIST (MERGEF ($FILENAME_MERGE (CAR L))
  358.                     `((DSK ,(STATUS UDIR)) NOFILE)))))                    
  359.     (DOLIST (FUNC (CDR L))
  360.         (NONSYMCHK FUNC '$SETUP_AUTOLOAD)
  361.         (PUTPROP (SETQ FUNC (DOLLARIFY-NAME FUNC)) FILE 'AUTOLOAD)
  362.         (ADD2LNC FUNC $PROPS)))
  363.   '$DONE)
  364. #+cl
  365. (DEFun $SETUP_AUTOLOAD (filename &rest functions)
  366.   (LET ((FILE  (string-trim "&$" filename)))
  367.     (DOLIST (FUNC functions)
  368.         (NONSYMCHK FUNC '$SETUP_AUTOLOAD)
  369.         (PUTPROP (SETQ FUNC (DOLLARIFY-NAME FUNC)) FILE 'AUTOLOAD)
  370.         (ADD2LNC FUNC $PROPS)))
  371.   '$DONE)
  372.  
  373. (DEFMFUN DOLLARIFY (L)
  374.   (LET ((ERRSET 'ERRBREAK1))
  375.       (CONS '(MLIST SIMP)
  376.         (MAPCAR #'(LAMBDA (X)
  377.                (LET (Y)
  378.                 (COND ((NUMBERP X) X)
  379.                   ((NUMBERP (SETQ Y (CAR (ERRSET
  380.                               (READLIST
  381.                                (MEXPLODEN X))
  382.                               NIL))))
  383.                    Y)
  384.                   (T (MAKEALIAS X)))))
  385.             L))))
  386.  
  387. (DEFMFUN MFBOUNDP (FUNC)
  388.  (OR (MGETL FUNC '(MEXPR MMACRO))
  389.      (GETL FUNC '(TRANSLATED-MMACRO MFEXPR* MFEXPR*S))))
  390.  
  391. (DEFMFUN FILENAMEL (FILE)
  392.  (COND ((ATOM FILE) (SETQ FILE (NCONS FILE)))
  393.        (($LISTP FILE) (SETQ FILE (CDR FILE)))
  394.        (T (MERROR "Not a proper filename ~M" FILE)))
  395.  (FILESTRIP FILE))
  396.  
  397.  
  398.  
  399. #+CL  ; This is quite different from the Maclisp version.
  400. (DEFMFUN LOADFILE (FILE FINDP PRINTP &AUX (SAVENO 0))
  401.   (AND FINDP (MEMQ $LOADPRINT '(NIL $LOADFILE)) (SETQ PRINTP NIL))
  402.   ;; Should really get the truename of FILE.
  403.   (IF PRINTP (FORMAT T "~%~A being loaded.~%" FILE))
  404.   (let* ((path (pathname FILE))
  405.      (tem (errset (LOAD (pathname FILE)))))
  406.     (or tem (merror "Load failed for ~A" (namestring path)))
  407.     (namestring path)))
  408.  
  409. (defun $directory (path)
  410.   (cons '(mlist) (mapcar 'namestring (directory ($filename_merge path))))
  411.   )
  412.  
  413. (DEFMFUN TRUEFNAME (FILE)
  414.  (OR (PROBE-FILE FILE)
  415.      #-cl (CLOSE (OPEN FILE '(IN FIXNUM)))
  416.     ; The OPEN is to generate the appropriate error handling.
  417.     ; The CLOSE is just to be nice.
  418.      #+Multics FILE
  419.     ; The Multics CLOSE function returns T always. 
  420.     ; At least we know we can open and close the file.
  421.     ; On Multics PROBE-FILE calls ALLFILES which demands access to
  422.     ; the directory. 
  423.      ))
  424.  
  425.  
  426. #+CL
  427. (DEFMFUN MTRUENAME (STREAM)
  428.   (MFILE-OUT (UNEXPAND-PATHNAME (FUNCALL STREAM ':NAME))))
  429.  
  430. (DEFMFUN CARFILE (FILE)  ; FILE is in OldIO list format.
  431.  (IF (= (LENGTH FILE) 3) (CDR FILE) FILE))
  432.  
  433. ;; SPECP is T if the file is being batched for TRANSL, or $LOAD, 
  434. ;;    or some other special purpose.
  435. #-Franz
  436. (DEFMACRO FILEPOS-CHECK () `(IF SPECP (SETQ FILEPOS (FILEPOS FILE-OBJ))))
  437.  
  438.  
  439. (DEFMSPEC $KILL (FORM) (MAPC #'KILL1 (CDR FORM)) #+GC (GCTWA) '$DONE)
  440.  
  441. (defvar $dont_kill_symbols_with_lisp_source_files  t "Prevents killing functional properties 
  442.  of items which have been translated and loaded")
  443.  
  444. (DEFMFUN KILL1 (X)
  445.  (funcall #'(LAMBDA (Z)
  446.    (COND ((AND ALLBUTL (MEMQ X ALLBUTL)))
  447.      ((EQ (SETQ X (GETOPR X)) '$LABELS)
  448.       (DOLIST (U (CDR $LABELS))
  449.           (COND ((AND ALLBUTL (MEMQ U ALLBUTL))
  450.              (SETQ Z (NCONC Z (NCONS U))))
  451.             (T (MAKUNBOUND U) (REMPROP U 'TIME)
  452.                (REMPROP U 'NODISP))))
  453.       (SETQ $LABELS (CONS '(MLIST SIMP) Z) $LINENUM 0 DCOUNT 0))
  454.      ((MEMQ X '($VALUES $ARRAYS $ALIASES $RULES $PROPS $LET_RULE_PACKAGES))
  455.       (MAPC #'KILL1 (CDR (SYMBOL-VALUE X))))
  456.      ((MEMQ X '($FUNCTIONS $MACROS $GRADEFS $DEPENDENCIES))
  457.       (MAPC #'(LAMBDA (Y) (KILL1 (CAAR Y))) (CDR (SYMBOL-VALUE X))))
  458.      ((EQ X '$MYOPTIONS))
  459.      ((EQ X '$TELLRATS) (SETQ TELLRATLIST NIL))
  460.      ((EQ X '$RATWEIGHTS) (SETQ *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP))))
  461.      ((EQ X '$FEATURES)
  462.       (COND ((NOT (EQUAL (CDR $FEATURES) FEATUREL))
  463.          (SETQ $FEATURES (CONS '(MLIST SIMP) (copy-top-level FEATUREL ))))))
  464.      ((OR (EQ X T) (EQ X '$ALL))
  465.       (MAPC #'KILL1 (CDR $INFOLISTS))
  466.       (SETQ $RATVARS '((MLIST SIMP)) VARLIST NIL GENVAR NIL
  467.         CHECKFACTORS NIL GREATORDER NIL LESSORDER NIL $GENSUMNUM 0
  468.         $WEIGHTLEVELS '((MLIST)) *RATWEIGHTS NIL $RATWEIGHTS '((MLIST SIMP))
  469.         TELLRATLIST NIL $DONTFACTOR '((MLIST)) $SETCHECK NIL)
  470.       (KILLALLCONTEXTS))
  471.      ((SETQ Z (ASSQ X '(($CLABELS . $INCHAR) ($DLABELS . $OUTCHAR)
  472.                 ($ELABELS . $LINECHAR))))
  473.       (MAPC #'(LAMBDA (Y) (REMVALUE Y '$KILL)) (GETLABELS* (EVAL (CDR Z)) NIL)))
  474.      ((AND (EQ (ml-typep X) 'fixnum) (NOT (< X 0))) (REMLABELS X))
  475.      ((and $dont_kill_symbols_with_lisp_source_files
  476.            (symbolp x)(or (get x 'translated)
  477.                   (and (fboundp x)
  478.                    (compiled-function-p
  479.                      (symbol-function x))))))
  480.      ((ATOM X)
  481.       (SETQ Z (OR (AND (MEMQ X (CDR $ALIASES)) (GET X 'NOUN)) (GET X 'VERB)))
  482.       (COND ((OR (NULL ALLBUTL) (NOT (MEMQ Z ALLBUTL)))
  483.          (REMVALUE X '$KILL) (REMCOMPARY X)
  484.          (IF (MEMQ X (CDR $CONTEXTS)) ($KILLCONTEXT X))
  485.          (IF (MGET X '$RULE)
  486.              (LET ((Y (RULEOF X)))
  487.               (COND (Y ($REMRULE Y X))
  488.                 (T #+MACLISP (REMPROP X 'EXPR)
  489.                    #-MACLISP (FMAKUNBOUND X)
  490.                    (DELQ X $RULES 1)))))
  491.          (IF (AND (GET X 'OPERATORS) (RULECHK X)) ($REMRULE X '$ALL))
  492.          (IF (MGET X 'TRACE) (MACSYMA-UNTRACE X))
  493.          (WHEN  (GET X 'TRANSLATED)
  494.                (REMOVE-TRANSL-FUN-PROPS X) 
  495.                (REMOVE-TRANSL-ARRAY-FUN-PROPS X))
  496.          (IF (NOT (GET X 'SYSCONST)) (REMPROP X 'MPROPS))
  497.          (DOLIST (U '(BINDTEST NONARRAY EVFUN EVFLAG OPERS SPECIAL MODE))
  498.              (REMPROP X U))
  499.          (DOLIST (U OPERS)
  500.              (IF (AND (REMPROP X U)
  501.                   (EQ (GET X 'OPERATORS) 'SIMPARGS1))
  502.                  (REMPROP X 'OPERATORS)))
  503.          (WHEN (MEMQ X (CDR $PROPS))
  504.                (REMPROP X 'SP2) (KILLFRAME X)
  505.                (LET ((Y (STRIPDOLLAR X)))
  506.                 (REMPROP Y 'ALPHABET) (zl-DELETE (GETCHARN Y 1) ALPHABET 1)))
  507.          (LET ((Y (GET X 'OP)))
  508.               (IF (AND Y (NOT (MEMQ Y MOPL)) (MEMQ Y (CDR $PROPS)))
  509.               (KILL-OPERATOR X)))
  510.          (REMALIAS X NIL) (DELQ X $ARRAYS 1) (REMPROPCHK X)
  511.          #+MACLISP (ARGS X NIL)
  512.          (zl-DELETE (zl-ASSOC (NCONS X) $FUNCTIONS) $FUNCTIONS 1)
  513.          (zl-DELETE (zl-ASSOC (NCONS X) $MACROS) $MACROS 1)
  514.          (LET ((Y (zl-ASSOC (NCONS X) $GRADEFS)))
  515.               (WHEN Y (REMPROP X 'GRAD) (zl-DELETE Y $GRADEFS 1)))
  516.          (zl-DELETE (zl-ASSOC (NCONS X) $DEPENDENCIES) $DEPENDENCIES 1)
  517.          (IF Z (KILL1 Z)))))
  518.      ((AND (EQ (CAAR X) 'MLIST) (EQ (ml-typep (CADR X)) 'fixnum)
  519.            (OR (AND (NULL (CDDR X)) (SETQ X (APPEND X (NCONS (CADR X)))))
  520.            (AND (EQ (ml-typep (CADDR X)) 'fixnum) (NOT (> (CADR X) (CADDR X))))))
  521.       (LET (($LINENUM (CADDR X))) (REMLABELS (f- (CADDR X) (CADR X)))))
  522.      ((SETQ Z (MGETL (CAAR X) '(HASHAR ARRAY))) (REMARRELEM Z X))
  523.      ((AND (EQ (CAAR X) '$ALLBUT)
  524.            (NOT (DOLIST (U (CDR X)) (IF (NOT (SYMBOLP U)) (RETURN T)))))
  525.       (LET ((ALLBUTL (CDR X))) (KILL1 T)))
  526.      (T (IMPROPER-ARG-ERR X '$KILL))))
  527.   NIL))
  528.  
  529.  
  530. (DEFMFUN REMLABELS (N)
  531.        (PROG (L X)
  532.          (SETQ L (LIST (EXPLODEN $INCHAR) (EXPLODEN $OUTCHAR) (EXPLODEN $LINECHAR)))
  533.     LOOP (SETQ X (MEXPLODEN $LINENUM))
  534.          (DO ((L L (CDR L)))( (NULL L)) (REMVALUE (IMPLODE (APPEND (CAR L) X)) '$KILL))
  535.          (IF (OR (MINUSP (SETQ N (f1- N))) (= $LINENUM 0)) (RETURN NIL))
  536.          (SETQ $LINENUM (f1- $LINENUM))
  537.          (GO LOOP)))
  538.  
  539. (DEFMFUN REMVALUE (X FN)
  540.  (COND ((NOT (SYMBOLP X)) (IMPROPER-ARG-ERR X FN))
  541.        ((BOUNDP X)
  542.     (LET (Y)
  543.          (COND ((OR (SETQ Y (MEMQ X (CDR $VALUES))) (MEMQ X (CDR $LABELS)))
  544.             (COND (Y (DELQ X $VALUES 1))
  545.               (T (DELQ X $LABELS 1)
  546.                  (REMPROP X 'TIME) (REMPROP X 'NODISP)
  547.                  (IF (NOT (ZEROP DCOUNT)) (SETQ DCOUNT (f1- DCOUNT)))))
  548.             (MAKUNBOUND X) T)
  549.            ((GET X 'SPECIAL) (MAKUNBOUND X) T)
  550.            (TRANSP (SET X X) T)
  551.            ((EQ X '$DEFAULT_LET_RULE_PACKAGE) T)
  552.            (T (MTELL "Warning: Illegal REMVALUE attempt:~%~M" X) NIL))))))
  553.  
  554. (DEFMFUN RULEOF (RULE)
  555.  (OR (MGET RULE 'RULEOF)
  556.      (LET ((OP (CAAADR (MGET RULE '$RULE))) L)
  557.       (AND (SETQ L (GET OP 'RULES)) (MEMQ RULE L) OP))))
  558.  
  559. (DEFMFUN $DEBUGMODE (X) (DEBUGMODE1 NIL X))
  560.  
  561.  
  562. #-NIL
  563. (DEFUN DEBUGMODE1 (ASSIGN-VAR Y)
  564.  ASSIGN-VAR  ; ignored
  565.  #+MACLISP (SETQ DEBUG (COND (Y (*RSET T) Y) (T (*RSET NIL))))
  566.  #+Franz   (prog2 (setq debug y) (debugging y))
  567.  #+akcl (if (eq y '$lisp) (si::use-fast-links y))
  568.  #+cl  (SETQ DEBUG (SETQ *RSET Y)))
  569.  
  570. #+cl
  571. (defun retrieve1 (a b &aux (eof '(nil)))
  572.   (let ((*mread-prompt* b) r )
  573.     (declare (special *mread-prompt*))
  574.     (catch 'macsyma-quit
  575.       (tagbody
  576.        top
  577.        (SETQ R    (dbm-read (or a *terminal-io*) nil eof))
  578.        (cond ((and (consp r) (keywordp (car r)))
  579.           (let ((value (break-call (car r) (cdr r) 'break-command)))
  580.         (if (eq value :resume) (return-from retrieve1 '$exit))
  581.         (go top))))
  582.           
  583.        )
  584.       )
  585.     (nth 2 r)
  586.     ))
  587.  
  588. #-NIL
  589. (DEFMFUN ERRBREAK (Y)  ; The ERRSET interrupt function
  590.  (COND
  591.   (DEBUG
  592.    ((LAMBDA (BRKLVL VARLIST GENVAR ERRBRKL LINELABLE)
  593.         (declare (special $help))
  594.      (PROG (X ^Q #.TTYOFF O^R #+MACLISP ERRSET #+LISPM ERROR-CALL TIM $%% 
  595.         #+Franz errset
  596.         $BACKTRACE  RETVAL OLDST ($help $help))
  597.        #+ (or franz maclisp cl)
  598.        (SETQ  ERRSET 'ERRBREAK1)
  599.        #+LISPM (setq ERROR-CALL 'ERRBREAK1)
  600.        (SETQ TIM (RUNTIME) $%% '$%%
  601.          ;; just in case baktrcl is cons'd on the stack
  602.          $BACKTRACE (CONS '(MLIST SIMP) (copy-list BAKTRCL)))
  603.        (SETQ O^R #.WRITEFILEP #.WRITEFILEP (AND #.WRITEFILEP (NOT DSKFNP)))
  604.        (cond ((eq y 'noprint))
  605.          (t 
  606.           (MTERPRI)
  607.           (IF Y (PRINC 'MACSYMA-BREAK) (PRINC 'ERROR-BREAK))
  608.           (UNLESS (ZEROP BRKLVL) (PRINC " level ") (PRINC BRKLVL))
  609.           (PRINC " Type EXIT; to quit, HELP; for more help.")))
  610.        (setq $help
  611.      "BACKTRACE; will give a successive list of forms 
  612.  (you must have already set ?DEBUG:ALL; for BACKTRACE to record) 
  613.      LISP; goes to lisp 
  614.      TOPLEVEL; goes all the way to top level 
  615.      EXIT; exits one level of the error break")
  616.        (MTERPRI)
  617.       A    (COND
  618.         ((NULL
  619.           (CATCH 'MACSYMA-BREAK
  620.               (LET ((STATE-PDL (CONS 'MACSYMA-BREAK STATE-PDL)))
  621.                (ERRSET
  622.                 (COND ((EQ (SETQ X
  623.                          (RETRIEVE1 NIL
  624.                             (if y "_ " "(debug) "
  625.                                    ))) '$EXIT)
  626.                    (TIMEORG TIM)
  627.                    (SETQ RETVAL 'EXIT) (GO END))
  628.                   ((EQ X '$LISP)
  629. #+MACLISP               (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL)))
  630.                     (*BREAK T 'LISP) (MTERPRI))  ; ^B also works
  631.                    (SETQ RETVAL 'LISP)
  632.                    (GO END))
  633.                   ((EQ X '$TOPLEVEL)
  634.                    (COND ((CATCH 'MBREAK
  635.                           (LET (ST OLDST REPHRASE
  636.                             (MBREAK (CONS BINDLIST LOCLIST)))
  637.                                (SETQ $LINENUM (f1+ $LINENUM))
  638.                                (CONTINUE)))
  639.                       (GO END))
  640.                      (T (MTELL-OPEN "Back to the break~%"))))
  641.                   (T (LET (($DISPFLAG DISPFLAG)) (SETQ $%% (MEVAL X)))
  642.                      (IF DISPFLAG (DISPLA $%%) (MTERPRI))))))))
  643.          (ERRLFUN1 ERRBRKL)
  644.          (MTELL-OPEN "~%(Still in break loop)~%")))
  645.          (GO A)
  646.       END  (unless (eq y 'noprint)
  647.            (PRINC "Exited from the break ")
  648.            (IF (NOT (ZEROP BRKLVL)) (PRINC BRKLVL))
  649.            (MTERPRI)
  650.            )
  651.        (IF O^R (SETQ #.WRITEFILEP T))
  652. #+(or Franz MACLISP)   (RETURN NIL) #+cl (RETURN RETVAL)))
  653.     (f1+ BRKLVL) VARLIST GENVAR (CONS BINDLIST LOCLIST) LINELABLE))))
  654.  
  655. #-NIL
  656. (DEFUN ERRBREAK1 (IGN) IGN NIL)  ; Used to nullify ERRSETBREAKs
  657.  
  658. #-NIL
  659. (DEFUN ERRBREAK2 (IGN) ign
  660.     ; An alternate ERRSET interr. function; used by PARSE and DISPLAY
  661.   #-cl IGNORE  ; ignored
  662.  (LET ((STATE-PDL (CONS 'LISP-BREAK STATE-PDL))) (*BREAK ERRBRKSW 'ERST)))
  663.  
  664.  
  665. ;; The ^B interrupt function
  666. (DEFUN MPAUSE (X)
  667.   X ;Ignored       
  668.   (LET ((STATE-PDL (LIST* 'LISP-BREAK '^B-BREAK STATE-PDL))
  669.     (MOREMSG "--Pause--"))
  670.        #+PDP10 (ENDPAGEFN T 'MORE-FUN)
  671.        #+PDP10 (BUFFCLEAR NIL)
  672.        (TIMESOFAR T)
  673.        #+MACLISP (NOINTERRUPT NIL)
  674.        (*BREAK T ^BMSG))
  675.   #+PDP10 (TTYRETFUN T))
  676.  
  677.  
  678.  
  679. (DEFMSPEC $TOBREAK (X)
  680.  (IF MBREAK (THROW 'MBREAK (CDR X))
  681.         (MERROR "TOBREAK may be used only within a MACSYMA break.")))
  682.  
  683. (DEFUN ERRLFUN (X)
  684.  (WHEN (NULL
  685.     (ERRSET
  686.      (PROGN #-LISPM (SETQ ^S NIL)
  687.         #+PDP10 (CLOSE SAVEFILE)
  688.         #-LISPM (IF LOADF (SETQ DEFAULTF LOADF LOADF NIL))
  689.         #+PDP10 (ENDPAGEFN T 'MORE-FUN))))
  690.        #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered."))
  691.  (IF $ERRORFUN (IF (NULL (ERRSET (MAPPLY1 $ERRORFUN NIL $ERRORFUN nil)))
  692.            (MTELL "~%Incorrect ERRORFUN")))
  693.  (WHEN (NULL
  694.     (ERRSET
  695.      (PROGN (IF (NOT (EQ X 'MQUIT)) (SUPUNBIND)) (CLEARSIGN))))
  696.        #-LISPM (SETQ ^Q NIL) (MTELL-OPEN "~%ERRLFUN has been clobbered."))
  697.  (WHEN (NULL X) (PRINC QUITMSG) (SETQ QUITMSG " ")))
  698.  
  699. (DEFUN SUPUNBIND NIL
  700.  (MUNBIND (REVERSE BINDLIST)) (DO NIL ((NULL LOCLIST)) (MUNLOCAL)))
  701.  
  702. (DEFMFUN ERRLFUN1 (MPDLS)
  703.        (DO ((L BINDLIST (CDR L)) (L1)) ((EQ L (CAR MPDLS)) (MUNBIND L1))
  704.        (SETQ L1 (CONS (CAR L) L1)))
  705.        (DO NIL ((EQ LOCLIST (CDR MPDLS))) (MUNLOCAL)))
  706.  
  707. (DEFMFUN GETALIAS (X) (COND ((GET X 'ALIAS)) ((EQ X '$FALSE) NIL) (T X)))
  708.  
  709. (DEFMFUN MAKEALIAS (X) (IMPLODE (CONS #\$ (EXPLODEN X))))
  710.  
  711.  
  712. ;; (DEFMSPEC $F (FORM) (SETQ FORM (FEXPRCHECK FORM)) ...)
  713. ;; makes sure that F was called with exactly one argument and
  714. ;; returns that argument.
  715.  
  716. (DEFMFUN FEXPRCHECK (FORM)
  717.   (IF (OR (NULL (CDR FORM)) (CDDR FORM))
  718.       (MERROR "~:M takes just one argument." (CAAR FORM))
  719.       (CADR FORM)))
  720.  
  721. (DEFMFUN NONSYMCHK (X FN)
  722.   (UNLESS (SYMBOLP X)
  723.       (MERROR "The argument to ~:M must be a symbolic name:~%~M" FN X)))
  724.  
  725. ;(DEFMFUN NONVARCHK (X FN FLAG 2NDP)
  726. ;  (WHEN (OR (MNUMP X) (INTEGERP X) (AND FLAG (ATOM X) (CONSTANT X))
  727. ;        (AND (NOT (ATOM X)) (NOT (EQ (CAAR X) 'MQAPPLY)) (MOPP1 (CAAR X))))
  728. ;    (MERROR "Non-variable~Margument to ~:M: ~M"
  729. ;        (IF 2NDP '|& 2nd | '|& |) FN X)))
  730.  
  731. (DEFMFUN PRINL (L) (DOLIST (X L) (PRINC X) (TYO #\Space)))
  732.  
  733. (DEFMFUN $PRINT N
  734.   (IF (= N 0)
  735.       '((MLIST SIMP))
  736.       (LET ((L (LISTIFY N)))
  737.     (DO ((L L (CDDR L)))( (NULL L)) (RPLACD L (CONS '| | (CDR L))))
  738.     (DISPLA (SETQ PRINTMSG (CONS '(MTEXT) L)))
  739.     (CADR (REVERSE L)))))
  740.  
  741.  
  742. (DEFMSPEC $PLAYBACK (X) (SETQ X (CDR X))
  743.   (LET ((STATE-PDL (CONS 'PLAYBACK STATE-PDL)))
  744.        (PROG (L L1 L2 NUMBP SLOWP NOSTRINGP INPUTP TIMEP GRINDP INCHAR LARGP)
  745.          (SETQ INCHAR (GETLABCHARN $INCHAR))
  746.             ; Only the 1st alphabetic char. of $INCHAR is tested
  747.          (SETQ TIMEP $SHOWTIME GRINDP $GRIND)
  748.          (DO ((X X (CDR X)))( (NULL X))
  749.          (COND ((EQ (ml-typep (CAR X)) 'fixnum) (SETQ NUMBP (CAR X)))
  750.                ((EQ (CAR X) '$ALL))
  751.                ((EQ (CAR X) '$SLOW) (SETQ SLOWP T))
  752.                ((EQ (CAR X) '$NOSTRING) (SETQ NOSTRINGP T))
  753.                ((EQ (CAR X) '$GRIND) (SETQ GRINDP T))
  754.                ((EQ (CAR X) '$INPUT) (SETQ INPUTP T))
  755.                ((MEMQ (CAR X) '($SHOWTIME $TIME)) (SETQ TIMEP (OR TIMEP T)))
  756.                ((MEMQ (CAR X) '($GCTIME $TOTALTIME)) (SETQ TIMEP '$ALL))
  757.                ((SETQ L2 (LISTARGP (CAR X)))
  758.             (SETQ L1 (NCONC L1 (GETLABELS (CAR L2) (CDR L2) NIL)) LARGP T))
  759.                (T (IMPROPER-ARG-ERR (CAR X) '$PLAYBACK))))
  760.          (COND ((AND LARGP (NULL NUMBP)) (GO LOOP))
  761.            ((AND (SETQ L (CDR $LABELS)) (NOT $NOLABELS)) (SETQ L (CDR L))))
  762.          (WHEN (OR (NULL NUMBP) (< (LENGTH L) NUMBP))
  763.            (SETQ L1 (REVERSE L)) (GO LOOP))
  764.          (DO ((I NUMBP (f1- I)) (L2)) ((ZEROP I) (SETQ L1 (NCONC L1 L2)))
  765.          (SETQ L2 (CONS (CAR L) L2) L (CDR L)))
  766.     LOOP (IF (NULL L1) (RETURN '$DONE))
  767.          ((LAMBDA (ERRSET INCHARP)
  768.            (ERRSET
  769.         (COND ((AND (NOT NOSTRINGP) INCHARP)
  770.                (LET ((LINELABLE (CAR L1))) (MTERPRI) (PRINTLABEL))
  771.                (IF GRINDP (MGRIND (MEVAL1 (CAR L1)) NIL)
  772.                   (MAPC #'TYO (MSTRING (MEVAL1 (CAR L1)))))
  773.                (IF (GET (CAR L1) 'NODISP) (PRINC '$) (PRINC '|;|))
  774.                (MTERPRI))
  775.               ((OR INCHARP
  776.                (PROG2 (WHEN (AND TIMEP (SETQ L (GET (CAR L1) 'TIME)))
  777.                     (SETQ X (GCTIMEP TIMEP (CDR L)))
  778.                     (MTELL-OPEN "~A msec." (CAR L))
  779.                    #+GC (IF X (MTELL-OPEN "  GCtime= ~A msec." (CDR L)))
  780.                     (MTERPRI))
  781.                   (NOT (OR INPUTP (GET (CAR L1) 'NODISP)))))
  782.                (MTERPRI) (DISPLA (LIST '(MLABLE) (CAR L1) (MEVAL1 (CAR L1)))))
  783.               (T (GO A)))))
  784.           'ERRBREAK2 (char= (GETLABCHARN (CAR L1)) INCHAR))
  785.          (IF (AND SLOWP (CDR L1) (NOT (CONTINUEP))) (RETURN '$TERMINATED))
  786.     A    (SETQ L1 (CDR L1))
  787.          (GO LOOP))))
  788.  
  789. (DEFUN LISTARGP (X)
  790.  (LET (HIGH)
  791.       (IF (AND ($LISTP X) (EQ (ml-typep (CADR X)) 'fixnum)
  792.            (OR (AND (NULL (CDDR X)) (SETQ HIGH (CADR X)))
  793.            (AND (EQ (ml-typep (SETQ HIGH (CADDR X))) 'fixnum)
  794.             (NOT (> (CADR X) HIGH)))))
  795.       (CONS (CADR X) HIGH))))
  796.  
  797. (DEFMSPEC $ALIAS (FORM)
  798.   (IF (ODDP (LENGTH (SETQ FORM (CDR FORM))))
  799.       (MERROR "ALIAS takes an even number of arguments."))
  800.   (DO ((L NIL (CONS (ALIAS (POP FORM) (POP FORM))
  801.             L)))
  802.       ((NULL FORM)
  803.        `((MLIST SIMP),@(NREVERSE L)))))
  804.  
  805. (DEFMFUN ALIAS (X Y)
  806.   (COND ((NONSYMCHK X '$ALIAS))
  807.     ((NONSYMCHK Y '$ALIAS))
  808.     ((NOT (EQ (GETCHAR X 1) '$))
  809.      (MERROR "-ed symbols may not be aliased. ~M" X))
  810.     ((GET X 'REVERSEALIAS)
  811.      (IF (NOT (EQ X Y))
  812.          (MERROR "~M already is aliased." X)))
  813.     (T (PUTPROP X Y'ALIAS)
  814.        (PUTPROP Y (STRIPDOLLAR X) 'REVERSEALIAS)
  815.        (ADD2LNC Y $ALIASES)
  816.        Y)))
  817.  
  818. (DEFMFUN REMALIAS (X &optional REMP)
  819.  (LET ((Y (AND (OR REMP (MEMQ X (CDR $ALIASES))) (GET X 'REVERSEALIAS))))
  820.       (COND ((AND Y (EQ X '%DERIVATIVE))
  821.          (REMPROP X 'REVERSEALIAS) (DELQ X $ALIASES 1)
  822.          (REMPROP '$DIFF 'ALIAS) '$DIFF)
  823.         (Y (REMPROP X 'REVERSEALIAS) (REMPROP X 'NOUN) (DELQ X $ALIASES 1)
  824.            (REMPROP (SETQ X (MAKEALIAS Y)) 'ALIAS) (REMPROP X 'VERB) X))))
  825.  
  826. (DEFMFUN STRIPDOLLAR (X)
  827.  (COND ((NOT (ATOM X))
  828.     (COND ((AND (EQ (CAAR X) 'BIGFLOAT) (NOT (MINUSP (CADR X)))) (IMPLODE (FPFORMAT X)))
  829.           (T (MERROR "Atomic arg required:~%~M" X))))
  830.        ((NUMBERP X) X)
  831.        ((NULL X) 'FALSE)
  832.        ((EQ X T) 'TRUE)
  833.        ((MEMQ (GETCHAR X 1) '($ % &))
  834.       #-(or Franz NIL cl) (IMPLODE (CDR (EXPLODEN X)))
  835.       #+cl (intern (subseq (string x) 1))
  836.       #+NIL (intern (substring x 1))
  837.       #+Franz (concat (substring x 2))    ;Nice start/end conventions.
  838.       )
  839.        (T X)))
  840.  
  841. (DEFMFUN FULLSTRIP (X) (MAPCAR #'FULLSTRIP1 X))
  842.  
  843. (DEFMFUN FULLSTRIP1 (X)
  844.  (OR (AND (NUMBERP X) X)
  845.      (GET X 'REVERSEALIAS)
  846.      (LET ((U (ASSQR X ALIASLIST))) (IF U (IMPLODE (STRING*1 (CAR U)))))
  847.      (STRIPDOLLAR X)))
  848.  
  849. (DEFUN STRING* (X)
  850.  (OR (AND (NUMBERP X) (EXPLODEN X))
  851.      (LET ((U (ASSQR X ALIASLIST))) (IF U (STRING*1 (CAR U))))
  852.      (STRING*1 X)))
  853.  
  854. (DEFUN STRING*1 (X) (LET (STRINGDISP $LISPDISP) (MAKESTRING X)))
  855.  
  856. (DEFUN MAKSTRING* (X)
  857.  (SETQ X (STRING* X))
  858.  (DO ((L X (CDR L)))( (NULL L)) (RPLACA L (ASCII (CAR L))))
  859.  X)
  860.  
  861. (DEFMFUN $NOUNIFY (X)
  862.  (LET (Y U)
  863.       (NONSYMCHK X '$NOUNIFY)
  864.       (SETQ X (AMPERCHK X))
  865.       (COND ((GET X 'VERB))
  866.         ((GET X 'NOUN) X)
  867.         ((OR (SETQ U (MEMQ (CAR (SETQ Y (EXPLODEC X))) '($ M)))
  868.          (NOT (EQ (CAR Y) '%)))
  869.          (SETQ Y (IMPLODE (CONS '% (IF U (CDR Y) Y))))
  870.          (PUTPROP Y X 'NOUN) (PUTPROP X Y 'VERB))
  871.         (T X))))
  872.  
  873. (DEFMFUN $VERBIFY (X)
  874.  (NONSYMCHK X '$VERBIFY)
  875.  (SETQ X (AMPERCHK X))
  876.  (COND ((GET X 'NOUN))
  877.        ((AND (char= (GETCHARN X 1) #\%)
  878.          (PROG2 ($NOUNIFY #+NIL (let ((s (copy-seq (symbol-name x))))
  879.                       (setf (schar s 0) #.(code-char #\$))
  880.                       (intern s))
  881.                   #-NIL (IMPLODE (CONS #\$ (CDR (EXPLODEN X)))))
  882.             (GET X 'NOUN))))
  883.        (T X)))
  884.  
  885. ;(DEFMFUN AMPERCHK (NAME)
  886. ; (IF (char= (GETCHARN NAME 1) #\&)
  887. ;     (OR (GET NAME 'OPR)
  888. ;     #+NIL (intern (nstring-upcase (string-append "$" name)))
  889. ;     #-NIL (IMPLODE (CONS #\$ (CASIFY-EXPLODEN NAME))))
  890. ;     NAME))
  891.  
  892. (DEFMFUN DOLLARIFY-NAME (NAME)
  893.  (LET ((N (GETCHARN NAME 1)))
  894.       (COND ((char= N #\&)
  895.          (OR (GET NAME 'OPR)
  896.          (LET ((NAMEL (CASIFY-EXPLODEN NAME)) AMPNAME DOLNAME)
  897.               (COND ((GET (SETQ AMPNAME (IMPLODE (CONS #\& NAMEL))) 'OPR))
  898.                 (T (SETQ DOLNAME (IMPLODE (CONS #\$ NAMEL)))
  899.                    (PUTPROP DOLNAME AMPNAME 'OP)
  900.                    (PUTPROP AMPNAME DOLNAME 'OPR)
  901.                    (ADD2LNC AMPNAME $PROPS)
  902.                    DOLNAME)))))
  903.         ((char= N #\%) ($VERBIFY NAME))
  904.         (T NAME))))
  905.  
  906. #-NIL
  907. (DEFMFUN $RANDOM N (APPLY #'RANDOM (LISTIFY N)))
  908.  
  909.  
  910. (DEFMSPEC $STRING (FORM)
  911.  (SETQ FORM (STRMEVAL (FEXPRCHECK FORM)))
  912.  (SETQ FORM (IF $GRIND (STRGRIND FORM) (MSTRING FORM)))
  913.  (SETQ ST (REVERSE FORM) REPHRASE T)
  914.  (IMPLODE (CONS #\& FORM)))
  915.  
  916. (DEFMFUN MAKSTRING (X)
  917.  (SETQ X (MSTRING X)) (DO ((L X (CDR L)))( (NULL L)) (RPLACA L (ASCII (CAR L)))) X)
  918.  
  919. (DEFMFUN STRMEVAL (X)
  920.  (COND ((ATOM X) (MEVAL1 X))
  921.        ((MEMQ (CAAR X) '(MSETQ MDEFINE MDEFMACRO)) X)
  922.        (T (MEVAL X))))
  923.  
  924. (PROG1 '(ALIAS properties)
  925.        (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS)
  926.                (PUTPROP (CADR X) (CADDR X) 'REVERSEALIAS))
  927.          '(($BLOCK MPROG BLOCK) ($LAMBDA LAMBDA LAMBDA)
  928.            ($ABS MABS ABS) ($SUBST $SUBSTITUTE SUBST)
  929.            ($GO MGO GO) ($SIGNUM %SIGNUM SIGNUM)
  930.            ($RETURN MRETURN RETURN) ($FACTORIAL MFACTORIAL FACTORIAL)
  931.            ($NOUUO NOUUO NOUUO) ($RSET *RSET RSET)
  932.            ($IBASE *read-base* *read-base*) ($OBASE *print-base* OBASE) ($NOPOINT *NOPOINT NOPOINT)
  933.            ($MODULUS MODULUS MODULUS) ($ZUNDERFLOW ZUNDERFLOW ZUNDERFLOW)
  934.            ($TTYOFF #.TTYOFF TTYOFF) ($WRITEFILE_ON #.WRITEFILEP WRITEFILE_ON)
  935.            ($MODE_DECLARE $MODEDECLARE MODE_DECLARE)))
  936.        (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ALIAS))
  937.          '(($RATCOEFF $RATCOEF) ($RATNUM $RATNUMER) ($TRUE T)
  938.            ($BINOM %BINOMIAL) ($DERIVATIVE $DIFF) ($PROD $PRODUCT)
  939.            ($BOTHCOEFF $BOTHCOEF))))
  940.  
  941. (DEFMFUN AMPERCHK (NAME)
  942.  " $AB ==> $AB,
  943.    $aB ==> $aB,
  944.    &aB ==> $AB,
  945.    |aB| ==> |aB| "
  946.  (IF (char= (GETCHARN NAME 1) #\&)
  947.      (OR (GET NAME 'OPR)
  948.      ;;note the nil version does something else
  949.      #+ NIL   
  950.      (nstring-upcase (string-append "$" name))
  951.      #-NIL(IMPLODE (CONS #\$ (CASIFY-EXPLODEN NAME))))
  952.      NAME))
  953.  
  954.  
  955. #+cl
  956. (defun casify-exploden (x)
  957.   (cond ((char= (getcharn x 1) #\&)
  958.      (cdr (exploden (string-upcase (string x)))))
  959.     (t (exploden x))))
  960. #-cl
  961. (DEFMFUN CASIFY-EXPLODEN (X)
  962.  (SETQ X (EXPLODEN X))
  963.  (IF (char= (CAR X) #\&) (MAPCAR #'CASIFY (CDR X)) (CDR X)))
  964.  
  965. (DEFMSPEC $STRINGOUT (X)  (SETQ X (CDR X))
  966.  (LET (FILE MAXIMA-ERROR L1 TRUENAME)
  967.     (SETQ FILE ($FILENAME_MERGE (CAR X)))
  968.     (SETQ X (CDR X))
  969.     (WITH-OPEN-FILE (SAVEFILE FILE :direction :output)
  970.    (COND ((NULL
  971.        (ERRSET
  972.         (DO ((L X (CDR L)))( (NULL L))
  973.         (COND ((MEMQ (CAR L) '($ALL $INPUT))
  974.                (SETQ L (NCONC (GETLABELS* $INCHAR T) (CDR L))))
  975.               ((EQ (CAR L) '$VALUES)
  976.                (SETQ L (NCONC (MAPCAN
  977.                     #'(LAMBDA (X)
  978.                         (IF (BOUNDP X)
  979.                         (NCONS (LIST '(MSETQ) X (SYMBOL-VALUE X)))))
  980.                     (CDR $VALUES))
  981.                       (CDR L))))
  982.               ((EQ (CAR L) '$FUNCTIONS)
  983.                (SETQ L (NCONC (MAPCAR
  984.                     #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL))
  985.                     (CDR $FUNCTIONS))
  986.                       (MAPCAN
  987.                     #'(LAMBDA (X)
  988.                         (IF (MGET X 'AEXPR)
  989.                         (NCONS (CONSFUNDEF X T NIL))))
  990.                     (CDR $ARRAYS))
  991.                       (MAPCAR
  992.                     #'(LAMBDA (X) (CONSFUNDEF (CAAR X) NIL NIL))
  993.                     (CDR $MACROS))
  994.                       (CDR L))))
  995.               ((SETQ L1 (LISTARGP (CAR L)))
  996.                (SETQ L (NCONC (GETLABELS (CAR L1) (CDR L1) T) (CDR L)))))
  997.         (IF (NULL L) (RETURN NIL))
  998.         (TERPRI SAVEFILE)
  999.         (IF $GRIND (MGRIND (STRMEVAL (CAR L)) SAVEFILE)
  1000.            #-Franz (PRINC (MAKNAM (MSTRING (STRMEVAL (CAR L))))
  1001.                   SAVEFILE)
  1002.            #+Franz (mapc #'(lambda (ch) (tyo ch savefile))
  1003.                    (mstring (strmeval (car l)))))
  1004.         (IF (OR (AND (ATOM (CAR L)) (GET (CAR L) 'NODISP)) (NOT $STRDISP))
  1005.             (TYO #\$ SAVEFILE)
  1006.             (TYO SEMI-COLON-CHAR SAVEFILE)))))
  1007.       (SETQ MAXIMA-ERROR T)))
  1008.    (SETQ TRUENAME (TRUENAME SAVEFILE))
  1009.    (TERPRI SAVEFILE))
  1010.    (IF MAXIMA-ERROR (LET ((ERRSET 'ERRBREAK1)) (MERROR "Error in STRINGOUT attempt")))
  1011.    (lisp::namestring TRUENAME)))
  1012. (DEFMSPEC $LABELS (CHAR)
  1013.  (SETQ CHAR (FEXPRCHECK CHAR))
  1014.  (NONSYMCHK CHAR '$LABELS)
  1015.  (CONS '(MLIST SIMP) (NREVERSE (GETLABELS* CHAR NIL))))
  1016.  
  1017. (DEFMFUN $%TH (X)
  1018.        (PROG (L OUTCHAR)
  1019.          (IF (OR (NOT (EQ (ml-typep X) 'fixnum)) (= X 0))
  1020.          (IMPROPER-ARG-ERR X '$%TH))
  1021.          (IF (> X 0) (SETQ X (f- X)))
  1022.          (IF (CDR $LABELS)
  1023.          (SETQ L (CDDR $LABELS) OUTCHAR (GETLABCHARN $OUTCHAR)))
  1024.     LOOP (IF (NULL L) (MERROR "Improper call to %TH"))
  1025.          (IF (AND (char= (GETLABCHARN (CAR L)) OUTCHAR) (= (SETQ X (f1+ X)) 0))
  1026.            ; Only the 1st alphabetic character of $OUTCHAR is tested.
  1027.          (RETURN (MEVAL (CAR L))))
  1028.          (SETQ L (CDR L))
  1029.          (GO LOOP)))
  1030.  
  1031. (DEFMFUN GETLABELS (N1 N2 FLAG)  ; FLAG = T for STRINGOUT, = NIL for PLAYBACK and SAVE.
  1032.  (DO ((I N1 (f1+ I)) (L1)
  1033.       (L (IF FLAG (LIST (EXPLODEN $INCHAR))
  1034.           (LIST (EXPLODEN $INCHAR) (EXPLODEN $LINECHAR)
  1035.             (EXPLODEN $OUTCHAR)))))
  1036.      ((> I N2) (NREVERSE L1))
  1037.      (DO ((L L (CDR L)) (X (MEXPLODEN I)) (Z)) ((NULL L))
  1038.      (IF (BOUNDP (SETQ Z (IMPLODE (APPEND (CAR L) X))))
  1039.          (SETQ L1 (CONS Z L1))))))
  1040.  
  1041. (DEFMFUN GETLABELS* (CHAR FLAG)  ; FLAG = T only for STRINGOUT
  1042.  (DO ((L (IF FLAG (CDDR $LABELS) (CDR $LABELS)) (CDR L))
  1043.       (CHAR (GETLABCHARN CHAR)) (L1))
  1044.      ((NULL L) L1)
  1045.      (IF (char= (GETLABCHARN (CAR L)) CHAR)
  1046.             ; Only the 1st alphabetic character is tested.
  1047.      (SETQ L1 (CONS (CAR L) L1)))))
  1048.  
  1049. (DEFMFUN GETLABCHARN (LABEL)
  1050.  (LET ((CHAR (GETCHARN LABEL 2))) (IF (char= CHAR #\%) (GETCHARN LABEL 3) CHAR)))
  1051. (DEFMSPEC $ERRCATCH (FORM)
  1052.  (LET ((ERRCATCH (CONS BINDLIST LOCLIST)) RET)
  1053.       (IF (NULL (SETQ RET (LET (DEBUG)
  1054.                    (ERRSET (MEVALN (CDR FORM)) LISPERRPRINT))))
  1055.       (ERRLFUN1 ERRCATCH))
  1056.       (CONS '(MLIST) RET)))
  1057.  
  1058. ;(DEFMFUN $ERROR N  ; Moved to MAXSRC;MERROR
  1059. ; (LET ((MSG (LISTIFY N)))
  1060. ;      (IF (> N 0) (APPLY #'$PRINT MSG))
  1061. ;      (IF ERRCATCH (ERROR))
  1062. ;      (IF DEBUG (LET (($ERROR (CONS '(MLIST SIMP) (FSTRINGC MSG))))
  1063. ;              (ERRBREAK NIL)))
  1064. ;      (MQUIT T)))
  1065.  
  1066.  
  1067. (DEFMSPEC $CATCH (FORM)
  1068.  (LET ((MCATCH (CONS BINDLIST LOCLIST)))
  1069.       (PROG1 (CATCH 'MCATCH (MEVALN (CDR FORM))) (ERRLFUN1 MCATCH))))
  1070.  
  1071. (DEFMFUN $THROW (EXP)
  1072.  (IF (NULL MCATCH) (MERROR "THROW not within CATCH:~%~M" EXP))
  1073.  (THROW 'MCATCH EXP))
  1074.  
  1075. (DEFMSPEC $TIME (L) (SETQ L (CDR L))
  1076.       #-cl
  1077.  (MTELL-OPEN "TIME or [TOTALTIME, GCTIME] in msecs.:~%")
  1078.  #+cl
  1079.  (format t "~&Time:")
  1080.  (CONS '(MLIST SIMP)
  1081.        (MAPCAR
  1082.     #'(LAMBDA (X)
  1083.        (OR (AND (SETQ X (OR (GET X 'TIME)
  1084.                 (AND (EQ X '$%) (CONS (CADR $LASTTIME)
  1085.                               (CADDR $LASTTIME)))))
  1086.             (IF (= (CDR X) 0)
  1087.             (CAR X)
  1088.             (LIST '(MLIST SIMP) (CAR X) (CDR X))))
  1089.            '$UNKNOWN))
  1090.     L)))
  1091.  
  1092. (DEFMFUN TIMEORG (TIM)
  1093.  (IF (> THISTIME 0) (SETQ THISTIME (f+ THISTIME (f- (RUNTIME) TIM)))))
  1094.  
  1095. ; Take difference of two times, return result in milliseconds.
  1096. #+LISPM
  1097. (DEFMFUN COMPUTIME (N1 N2) (// (f* 50. (TIME-DIFFERENCE
  1098.                     N1 N2)) 3.))
  1099.  
  1100.  
  1101. #+CL (PROGN 'COMPILE
  1102. (DEFMFUN $QUIT () nil #+kcl (bye) #+cmu (ext:quit) #+sbcl (sb-ext:quit) #+clisp (ext:quit)
  1103.  
  1104.    (quit)
  1105.    #+excl "don't know quit function")
  1106. (DEFMFUN $LOGOUT () (LOGOUT))
  1107. )
  1108. (DEFMFUN FILEPRINT (FNAME)  ; Takes filename in NAMELIST format.
  1109.  (COND ($FILE_STRING_PRINT (PRINC (NAMESTRING FNAME)) (PRINC "  "))
  1110.        (T (PRINC "[")
  1111.       (PRINC (CADR FNAME)) (PRINC ", ")
  1112.       (PRINC (CADDR FNAME)) (PRINC ", ")
  1113.       (WHEN (CDDDR FNAME) (PRINC (CADDDR FNAME)) (PRINC ", "))  ; For TOPS-20
  1114.       (PRINC (CAAR FNAME)) (PRINC ", ")
  1115.       (PRINC (CADAR FNAME)) (PRINC "]  "))))
  1116.  
  1117. (DEFMFUN MFILE-OUT (FNAME)  ; Takes filename in NAMELIST or OldIO list format.
  1118.  (IF $FILE_STRING_PRINT
  1119.      (IMPLODE (CONS #\& (EXPLODEN (NAMESTRING FNAME))))
  1120.      (DOLLARIFY (IF (ATOM (CAR FNAME)) FNAME (APPEND (CDR FNAME) (CAR FNAME))))))
  1121.  
  1122. ; File-processing stuff.  Lisp Machine version in MC:LMMAX;LMSUP.
  1123.  
  1124.  
  1125.  
  1126. (DEFUN MFILE NIL
  1127.    (FULLSTRIP (LIST $FILENAME (SETQ $FILENUM (f1+ $FILENUM)) $DEVICE $DIREC)))
  1128.  
  1129.  
  1130. ;; This prevents single blank lines from appearing at the top of video 
  1131. ;; terminals.  If at the upper left corner and we want to print a blank 
  1132. ;; line, leave the cursor there and send the blank line to transcript 
  1133. ;; files only.
  1134.  
  1135. #+(OR PDP10 NIL CL)
  1136. (DEFMFUN MTERPRI (&AUX X)
  1137.  #-nocp (setq x  (CURSORPOS))
  1138.  (IF (AND SMART-TTY X (EQUAL X '(0 . 0)))
  1139.      (LET ((#.TTYOFF T)) (TERPRI))
  1140.      (TERPRI)))
  1141.  
  1142. #+lispm
  1143. (DECLARE-top (SPECIAL TV:MORE-PROCESSING-GLOBAL-ENABLE))
  1144.  
  1145. #+LISPM
  1146. (DEFMFUN MORE-FUN (FILE)
  1147.   FILE ;ignored
  1148.  (send  *terminal-io* :send-if-handles :more-exception))
  1149.  
  1150.  
  1151. #+LISPM
  1152. (DEFUN MORE-FUN-INTERNAL (*terminal-io*
  1153.               &AUX (*standard-input* *terminal-io*))
  1154. ;;                 'SI:TERMINAL-IO-SYN-STREAM))
  1155.                           ;; SI:SYN-TERMINAL-IO))
  1156.  ; This clears the rest of the screen, unless we're at the bottom
  1157.  ; or too close to the top.
  1158.  (COND ((NOT (OR (< (CAR (CURSORPOS)) 10.)
  1159.          (= (- TTYHEIGHT 2) (CAR (CURSORPOS)))))
  1160.     (CURSORPOS 'E)))
  1161.  ; Now go to the bottom of the screen and cause a more, unless disabled.
  1162.  (COND (TV:MORE-PROCESSING-GLOBAL-ENABLE
  1163.     (CURSORPOS 'Z) (CURSORPOS 'L)
  1164.     ((LAMBDA (^Q)
  1165.       ((LAMBDA (#.WRITEFILEP #.TTYOFF STATE-PDL)
  1166.         (PRINC MOREMSG) (TYIPEEK)
  1167.         ; Now see what the user feels like typing in.
  1168.         (COND ($MOREWAIT
  1169.            (DO ((L (COND ((EQ $MOREWAIT '$ALL) '(#\SPACE #\RETURN))
  1170.                  (T '(#\SPACE #\RETURN #\RUBOUT)))))
  1171.                ((zl-MEMBER (TYIPEEK) L))
  1172.               (TYI T))) ; eat other characters
  1173.           (T (DO () ((NOT (zl-MEMBER (TYIPEEK) '(4 19. 21. 22. 29.))))
  1174.              (TYI T)))) ; eat ^], etc. 
  1175.         ; Now erase the MORE message
  1176.         (COND (SMART-TTY (CURSORPOS 'Z) (CURSORPOS 'L)) (T (TERPRI))))
  1177.        NIL NIL (CONS 'MORE-WAIT STATE-PDL))
  1178.       ; Now decide whether to continue or flush
  1179.       (COND ((char= #\Space (TYIPEEK))
  1180.          (IF MORECONTINUE (LET (#.WRITEFILEP #.TTYOFF) (PRINC MORECONTINUE)))
  1181.          (TYI T)) ; eat the space
  1182.         ((char= #\RUBOUT (TYIPEEK))
  1183.          (LET ((#.TTYOFF T)) (TERPRI))
  1184.          (IF MOREFLUSH (PRINC MOREFLUSH))
  1185.          (TYI T)  ; eat the rubout
  1186.          (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T))
  1187.                #.WRITEFILEP (AND #.WRITEFILEP (NULL MOREFLUSH))))
  1188.         (T (COND ((OR (MEMQ 'BATCH STATE-PDL)
  1189.                   (AND (char< (TYIPEEK) #\SPACE)
  1190.                    (NOT (zl-MEMBER (TYIPEEK)
  1191.                       #.(cons 'list    (mapcar    'code-char '(2 7 11. 12. 25. 27. 28. 29. 30.))))
  1192. ;                           '(#\Alpha #\Pi
  1193. ;                            #\Up-Arrow
  1194. ;                            #\Plus-Minus
  1195. ;                            #\Right-Arrow
  1196. ;                            #\Lozenge
  1197. ;                            #\Less-Or-Equal
  1198. ;                            #\Greater-Or-Equal
  1199. ;                            #\Equivalence)
  1200.                            ))
  1201.                   (char>= (TYIPEEK) #. (code-char 128.)))
  1202.               (TYI T)))  ; eat cr or other control character.
  1203.            (IF MOREFLUSH (LET (#.WRITEFILEP #.TTYOFF) (PRINC MOREFLUSH)))
  1204.            (SETQ MORE-^W (OR MORE-^W (AND MOREFLUSH T))))))
  1205.      NIL)))
  1206.  ; Now home up, or advance to next line, and continue display.
  1207.  (IF SMART-TTY
  1208.      (COND (RUBOUT-TTY (LET (#.TTYOFF) (CURSORPOS T T) (CURSORPOS 'L)))
  1209.        (T (MAXIMA-SLEEP 0.4) (FORMFEED)))
  1210.      (LET (#.TTYOFF #.WRITEFILEP) (TERPRI))))
  1211.  
  1212. (DEFMFUN $PAGEPAUSE (X) (PAGEPAUSE1 NIL X))
  1213.  
  1214.  
  1215. #-PDP10
  1216. (DEFUN PAGEPAUSE1 (X Y)
  1217.   X Y (MERROR "PAGEPAUSE does not exist in this system."))
  1218.  
  1219.  
  1220. #+(or cl LISPM)
  1221. (DEFMSPEC $STATUS (FORM)
  1222.   (setq form (cdr form))
  1223.   (LET* ((KEYWORD (car FORM))
  1224.      (FEATURE (cadr form)))
  1225.        (assert (symbolp keyword))
  1226.        (assert (symbolp feature))
  1227.       (CASE KEYWORD
  1228.     ($FEATURE (COND ((NULL FEATURE) (DOLLARIFY #-cl (STATUS FEATURES)
  1229.                            #+cl *features*))
  1230.             ((MEMQ (intern (symbol-name
  1231.                      (FULLSTRIP1 FEATURE)) 'keyword)
  1232.                    #-cl(STATUS FEATURES)
  1233.                    #+cl *features*
  1234.                    ) T)))
  1235.     ($STATUS '((MLIST SIMP) $FEATURE $STATUS))
  1236.     (T (MERROR "Unknown argument - STATUS:~%~M" KEYWORD)))))
  1237.  
  1238. #+(or cl lispm)
  1239. (defquote $sstatus (status-function item)
  1240.   (cond ((equal status-function '$feature)
  1241.      (pushnew ($mkey item) *features*) t)
  1242.     ((equal status-function '$nofeature)
  1243.      (setq *features* (delete ($mkey item) *features*)) t)
  1244.     (t (error "know only how to set and remove feature status"))))
  1245.  
  1246. ;; End of disk GC conditionalization.
  1247.  
  1248. #-PDP10 (PROGN 'COMPILE
  1249. (DEFMFUN $DSKGC (X) X NIL)
  1250. (DEFUN DSKGC1 (X Y) X Y NIL)
  1251. )
  1252.  
  1253.  
  1254.  
  1255. #+CL (SETQ ERROR-CALL 'ERRBREAK)
  1256.  
  1257. (PROGN (DO ((L '($SQRT $ERF $SIN $COS $TAN $LOG $PLOG $SEC $CSC $COT $SINH $COSH
  1258.            $TANH $SECH $CSCH $COTH $ASIN $ACOS $ATAN $ACOT $ACSC $ASEC $ASINH
  1259.            $ACOSH $ATANH $ACSCH $ASECH $ACOTH $BINOMIAL $GAMMA $GENFACT $DEL)
  1260.        (CDR L)))( (NULL L))
  1261.        ((LAMBDA (X)
  1262.          (PUTPROP (CAR L) X 'ALIAS)
  1263.          (PUTPROP X (STRIPDOLLAR (CAR L)) 'REVERSEALIAS))
  1264.         ($NOUNIFY (CAR L))))
  1265.        ($NOUNIFY '$SUM) ($NOUNIFY '$PRODUCT)
  1266.        ($NOUNIFY '$INTEGRATE) ($NOUNIFY '$LIMIT)
  1267.        (DEFPROP $DIFF %DERIVATIVE VERB) (DEFPROP %DERIVATIVE $DIFF NOUN)
  1268.        '(NOUN properties))
  1269.  
  1270. (PROGN (MAPC #'(LAMBDA (X) (PUTPROP (CAR X) (CADR X) 'ASSIGN))
  1271.          '(($DEBUGMODE DEBUGMODE1) ($BOTHCASES BOTHCASES1)
  1272.            ($PAGEPAUSE PAGEPAUSE1) ($DSKGC DSKGC1)
  1273.            ($TTYINTFUN TTYINTFUNSETUP)
  1274.            ($FPPREC FPPREC1) ($POISLIM POISLIM1)
  1275.            ($default_let_rule_package let-rule-setter)
  1276.            ($current_let_rule_package let-rule-setter)
  1277.            ($let_rule_packages let-rule-setter)))
  1278.        (MAPC #'(LAMBDA (X) (PUTPROP X 'NEVERSET 'ASSIGN)) (CDR $INFOLISTS))
  1279.        (DEFPROP $CONTEXTS NEVERSET ASSIGN)
  1280.        '(ASSIGN properties))
  1281.  
  1282.  
  1283.  
  1284. ; Undeclarations for the file:
  1285. (declare-top (NOTYPE I N N1 N2 U1))
  1286.  
  1287. #-(or cl NIL)
  1288. (EVAL-WHEN (EVAL COMPILE) (SETQ *print-base* OLD-BASE *read-base* OLD-IBASE))
  1289. #+cl
  1290. (EVAL-WHEN (EVAL COMPILE) (SETQ *PRINT-BASE* OLD-BASE *READ-BASE* OLD-IBASE))
  1291.  
  1292. nil
  1293.